home *** CD-ROM | disk | FTP | other *** search
/ Language/OS - Multiplatform Resource Library / LANGUAGE OS.iso / t3_1 / encorsrc.lha / encore_sources / sys / kernel.t < prev    next >
Text File  |  1988-05-02  |  8KB  |  238 lines
  1. (herald kernel (env tsys))
  2.  
  3. ;;; Copyright (c) 1985 Yale University
  4. ;;;     Authors: N Adams, R Kelsey, D Kranz, J Philbin, J Rees.
  5. ;;; This material was developed by the T Project at the Yale University Computer 
  6. ;;; Science Department.  Permission to copy this software, to redistribute it, 
  7. ;;; and to use it for any purpose is granted, subject to the following restric-
  8. ;;; tions and understandings.
  9. ;;; 1. Any copy made of this software must include this copyright notice in full.
  10. ;;; 2. Users of this software agree to make their best efforts (a) to return
  11. ;;;    to the T Project at Yale any improvements or extensions that they make,
  12. ;;;    so that these may be included in future releases; and (b) to inform
  13. ;;;    the T Project of noteworthy uses of this software.
  14. ;;; 3. All materials developed as a consequence of the use of this software
  15. ;;;    shall duly acknowledge such use, in accordance with the usual standards
  16. ;;;    of acknowledging credit in academic research.
  17. ;;; 4. Yale has made no warrantee or representation that the operation of
  18. ;;;    this software will be error-free, and Yale is under no obligation to
  19. ;;;    provide any services, by way of maintenance, update, or otherwise.
  20. ;;; 5. In conjunction with products arising from the use of this material,
  21. ;;;    there shall be no use of the name of the Yale University nor of any
  22. ;;;    adaptation thereof in any advertising, promotional, or sales literature
  23. ;;;    without prior written consent from Yale in each case.
  24. ;;;
  25.  
  26. ;;; Random low level global variables.
  27.  
  28. (lset *suspended-system*    nil)
  29. (lset **reset**             nil)
  30. (lset *top-level*           nil)
  31.  
  32. ;;; *BREAK-LEVEL* is set to 0 during the evaluation of Z top level
  33. ;;; forms.  If we happen to incur some sort of error while doing
  34. ;;; system initialization the breakloop will start up at level one,
  35. ;;; rather than zero.
  36. ;++ we could set it up so that it printed the module if *break-level*
  37. ;++ is greater than n.
  38.  
  39. (lset *break-level*    0)
  40. (lset **ret**          nil)
  41. (lset *z?*             t)
  42.  
  43. ;;; The entry and re-entry into the kernel after boot-strapping.
  44.  
  45. (define (TOP-LEVEL)
  46.   (catch top
  47.     (set *break-level* -1)
  48.     (set **reset** top)
  49.     (*top-level*))
  50.   (top-level))
  51.  
  52. (define (RESET) (**reset**))
  53.  
  54. (define (breakpoint . args)
  55.   (apply (if *z?* z-breakpoint t-breakpoint) args))
  56.  
  57. (define (ret . vals)
  58.   (apply **ret** vals))
  59.  
  60. ;;; Random low level procedures and objects.
  61.  
  62. (define-integrable (true . args)  (ignore args) '#t)
  63. (define-integrable (false . args) (ignore args) '#f)
  64. (define-integrable (true? x)      (if x '#t '#f))
  65.  
  66. ;;; GC-STAMP must be present even if the GC isn't.
  67.  
  68. (define-integrable (gc-stamp)
  69.   (system-global slink/gc-stamp))
  70.  
  71. (define (increment-gc-stamp)
  72.   (defer-interrupts
  73.     (set (system-global slink/gc-stamp)
  74.          (fx+ (system-global slink/gc-stamp) 1))
  75.     (system-global slink/gc-stamp)))
  76.  
  77. ;;; "Reasonableness" predicate.  This should cons as little as
  78. ;;; possible in order to use it debugging gc. This may become hairier.
  79.  
  80. (define (reasonable? obj)
  81.   (select (descriptor-tag obj)
  82.     ((tag/fixnum) t)
  83.     ((tag/immediate)
  84.      (or (template-header? obj)
  85.          (char? obj)
  86.          (nonvalue? obj)
  87.          (true-header? obj)))
  88.     ((tag/pair)
  89.      (points-to-reasonable-memory obj))
  90.     (else
  91.      (if (points-to-reasonable-memory obj)
  92.          (cond ((template? obj) t)
  93.                ((template? (extend-header obj))
  94.                 (points-to-reasonable-memory (extend-header obj)))
  95.                (else                     
  96.                 (fx>= (vector-length obj) 0)))
  97.          nil))))
  98.  
  99. (define (points-to-reasonable-memory obj)
  100.   (let ((first (descriptor->fixnum obj)))
  101.     (cond ((and (fx>= first (system-global slink/initial-pure-memory-begin))
  102.                 (fx< first (system-global slink/initial-pure-memory-end)))
  103.            'initial-pure)
  104.           ((and (fx>= first (system-global slink/initial-impure-memory-begin))
  105.                 (fx< first (system-global slink/initial-impure-memory-end)))
  106.            'initial-impure)
  107.           ((and (fx>= first (process-global task/area-begin))
  108.                 (fx< first (process-global task/area-frontier)))
  109.            'heap)
  110.           ;; remember the stack is high to low memory, but extends
  111.           ;; are oriented in the same direction whether on the stack
  112.           ;; or not.
  113.           ((and (fx>= first (stack-pointer))
  114.                 (fx<= first (process-global task/stack)))
  115.            'stack)
  116.           (else nil))))
  117.  
  118. (define (points-to-initial-impure-memory? obj)
  119.   (let ((first (descriptor->fixnum obj)))
  120.     (and (fx>= first (system-global slink/initial-impure-memory-begin))
  121.          (fx< first (system-global slink/initial-impure-memory-end)))))
  122.  
  123.  
  124. ;;; repl-wont-print
  125.  
  126. (define-predicate repl-wont-print?)
  127.  
  128. (define repl-wont-print
  129.   (object nil
  130.     ((repl-wont-print? self) t)
  131.     ((identification self) 'repl-wont-print)))
  132.  
  133.  
  134. ;;; Undefined Value Note: It would be nice if undefined-value closed
  135. ;;; over the environment in which it was called.  Thus, for example,
  136. ;;; being able to print the name of the procedure in which the
  137. ;;; undefined value was created.  UNDEFINED-EFFECT is handled by
  138. ;;; the compiler.
  139.  
  140. ;;; Enforce ;++ move to error?
  141.  
  142. (define (*enforce type obj)
  143.   (catch caller
  144.     (if (type obj) 
  145.         obj
  146.         (*enforce type
  147.                    (error "(~s ~s ~s) failed in ~a"
  148.                           'enforce
  149.                           (or (identification type) type)
  150.                           obj
  151.                           (let* ((frame (escape-procedure-frame caller))
  152.                                  (thing (cond ((interpreter-frame? frame)
  153.                                                (interpreter-frame-code frame))
  154.                                               (else
  155.                                                (extend-header frame)))))
  156.                             (or (get-proc-name thing)
  157.                                 "(anonymous)")))))))
  158.  
  159. (define (*check-arg predicate expression where)
  160.   (if (predicate expression)
  161.       expression
  162.       (*check-arg predicate
  163.         (error "some argument didn't answer true to ~S as expected~
  164.                 ~%  (~S ... ~S ...)"
  165.                 (or (identification predicate) predicate)
  166.                 (or (identification where) where) expression)
  167.                 where)))
  168.  
  169. (define value-of-assert (undefined-value 'assert))
  170.  
  171. (define (assert something)
  172.   (cond ((not something)
  173.          (error "assertion failed")))
  174.          value-of-assert)
  175.  
  176. ;;; NO-OP prevents compiler optimizations.  It must be an unknown
  177. ;;; procedure.
  178.  
  179. (define (no-op x) x)
  180.  
  181. ;;; Modularity wins again.
  182. ;;; This is one of the places that having optional arguments be
  183. ;;; returned as a list loses, since we can't distinguish between
  184. ;;; no argument and '() as an argument.
  185. ;++ the arg order has changed from that of t2.  Release.
  186.  
  187. (define (make-simple-switch id type . val)
  188.   (let ((s (lambda (new) (set val (check-arg type new id)))))
  189.     (if (null? val) (set val (undefined-value id)) (s (car val)))
  190.     (object (lambda () val)
  191.       ((setter self) s)
  192.       ((identification self) id)
  193.       ((print-type-string self) "Switch"))))
  194.  
  195. ;;; Low level switches
  196.  
  197. (define-simple-switch z-system-present?     boolean? '#f)
  198. (define-simple-switch gc-present?           boolean? '#f)
  199. (define-simple-switch loader-present?       boolean? '#f)
  200. (define-simple-switch tables-present?       boolean? '#f)
  201. (define-simple-switch file-system-present?  boolean? '#f)
  202. (define-simple-switch syntax-present?       boolean? '#f)
  203.  
  204. (define (make-agenda id . agenda)
  205.   (object (lambda ()
  206.             (do ((l agenda (cdr l)))
  207.                 ((null? l))
  208.               ((car l))))
  209.     ((insert self item)
  210.      (set agenda (append agenda (list item)))
  211.      (no-value))
  212.     ((delete self item)
  213.      (set agenda (delq! item agenda)) 
  214.      (no-value))
  215.     ((identification self) id)
  216.     ((print-type-string self) 'agenda)))
  217.  
  218. ;;; Random global procedures
  219.  
  220. (define (format port fmt . args)
  221.   (let ((port (if (eq? port t) (standard-output) port)))
  222.     (cond (*z?*
  223.            (z-format-aux port fmt args '#t))
  224.           (else
  225.            (t-format-aux port fmt args (interactive? port))))))
  226.  
  227. (define (prompt fd fmt . args)
  228.   (cond (*z?*
  229.          (z-format-aux fd fmt args '#t))
  230.         (else
  231.          (t-format-aux fd fmt args '#t))))
  232.  
  233. (define (dbg fmt . args)
  234.   (cond (*z?*
  235.          (z-format-aux (debug-output) fmt args '#t))
  236.         (else
  237.          (t-format-aux (debug-output) fmt args '#t))))
  238.